home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / xsdmem.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  15KB  |  680 lines
  1. /* xsdmem.c - xscheme dynamic memory management routines */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* virtual machine registers */
  9. LVAL xlfun;        /* current function */
  10. LVAL xlenv;        /* current environment */
  11. LVAL xlval;        /* value of most recent instruction */
  12. LVAL *xlsp;        /* value stack pointer */
  13.  
  14. /* stack limits */
  15. LVAL *xlstkbase;    /* base of value stack */
  16. LVAL *xlstktop;        /* top of value stack (actually, one beyond) */
  17.  
  18. /* variables shared with xsimage.c */
  19. FIXTYPE total;        /* total number of bytes of memory in use */
  20. FIXTYPE gccalls;    /* number of calls to the garbage collector */
  21.  
  22. /* node space */
  23. NSEGMENT *nsegments;    /* list of node segments */
  24. NSEGMENT *nslast;    /* last node segment */
  25. int nscount;        /* number of node segments */
  26. FIXTYPE nnodes;        /* total number of nodes */
  27. FIXTYPE nfree;        /* number of nodes in free list */
  28. LVAL fnodes;        /* list of free nodes */
  29.  
  30. /* vector (and string) space */
  31. VSEGMENT *vsegments;    /* list of vector segments */
  32. VSEGMENT *vscurrent;    /* current vector segment */
  33. int vscount;        /* number of vector segments */
  34. LVAL *vfree;        /* next free location in vector space */
  35. LVAL *vtop;        /* top of vector space */
  36.  
  37. /* external variables */
  38. extern LVAL s_unbound;        /* *UNBOUND* symbol */
  39. extern LVAL obarray;        /* *OBARRAY* symbol */
  40. extern LVAL default_object;    /* default object */
  41. extern LVAL eof_object;        /* eof object */
  42. extern LVAL true;        /* truth value */
  43.  
  44. /* external routines */
  45. extern unsigned char *calloc();
  46.  
  47. /* forward declarations */
  48. FORWARD LVAL allocnode();
  49. FORWARD LVAL allocvector();
  50.  
  51. /* cons - construct a new cons node */
  52. LVAL cons(x,y)
  53.   LVAL x,y;
  54. {
  55.     LVAL nnode;
  56.  
  57.     /* get a free node */
  58.     if ((nnode = fnodes) == NIL) {
  59.     check(2);
  60.     push(x);
  61.     push(y);
  62.     findmemory();
  63.     if ((nnode = fnodes) == NIL)
  64.         xlabort("insufficient node space");
  65.     drop(2);
  66.     }
  67.  
  68.     /* unlink the node from the free list */
  69.     fnodes = cdr(nnode);
  70.     --nfree;
  71.  
  72.     /* initialize the new node */
  73.     nnode->n_type = CONS;
  74.     rplaca(nnode,x);
  75.     rplacd(nnode,y);
  76.  
  77.     /* return the new node */
  78.     return (nnode);
  79. }
  80.  
  81. /* newframe - create a new environment frame */
  82. LVAL newframe(parent,size)
  83.   LVAL parent; int size;
  84. {
  85.     LVAL newframe;
  86.     newframe = cons(newvector(size),parent);
  87.     newframe->n_type = ENV;
  88.     return (newframe);
  89. }
  90.  
  91. /* cvstring - convert a string to a string node */
  92. LVAL cvstring(str)
  93.   unsigned char *str;
  94. {
  95.     LVAL val;
  96.     val = newstring(strlen(str)+1);
  97.     strcpy(getstring(val),str);
  98.     return (val);
  99. }
  100.  
  101. /* cvsymbol - convert a string to a symbol */
  102. LVAL cvsymbol(pname)
  103.   unsigned char *pname;
  104. {
  105.     LVAL val;
  106.     val = allocvector(SYMBOL,SYMSIZE);
  107.     cpush(val);
  108.     setvalue(val,s_unbound);
  109.     setpname(val,cvstring(pname));
  110.     setplist(val,NIL);
  111.     return (pop());
  112. }
  113.  
  114. /* cvfixnum - convert an integer to a fixnum node */
  115. LVAL cvfixnum(n)
  116.   FIXTYPE n;
  117. {
  118.     LVAL val;
  119.     if (n >= SFIXMIN && n <= SFIXMAX)
  120.     return (cvsfixnum(n));
  121.     val = allocnode(FIXNUM);
  122.     val->n_int = n;
  123.     return (val);
  124. }
  125.  
  126. /* cvflonum - convert a floating point number to a flonum node */
  127. LVAL cvflonum(n)
  128.   FLOTYPE n;
  129. {
  130.     LVAL val;
  131.     val = allocnode(FLONUM);
  132.     val->n_flonum = n;
  133.     return (val);
  134. }
  135.  
  136. /* cvchar - convert an integer to a character node */
  137. LVAL cvchar(ch)
  138.   int ch;
  139. {
  140.     LVAL val;
  141.     val = allocnode(CHAR);
  142.     val->n_chcode = ch;
  143.     return (val);
  144. }
  145.  
  146. /* cvclosure - convert code and an environment to a closure */
  147. LVAL cvclosure(code,env)
  148.   LVAL code,env;
  149. {
  150.     LVAL val;
  151.     val = cons(code,env);
  152.     val->n_type = CLOSURE;
  153.     return (val);
  154. }
  155.  
  156. /* cvpromise - convert a procedure to a promise */
  157. LVAL cvpromise(code,env)
  158.   LVAL code,env;
  159. {
  160.     LVAL val;
  161.     val = cons(cvclosure(code,env),NIL);
  162.     val->n_type = PROMISE;
  163.     return (val);
  164. }
  165.  
  166. /* cvmethod - convert code and an environment to a method */
  167. LVAL cvmethod(code,class)
  168.   LVAL code,class;
  169. {
  170.     LVAL val;
  171.     val = cons(code,class);
  172.     val->n_type = METHOD;
  173.     return (val);
  174. }
  175.  
  176. /* cvsubr - convert a function to a subr/xsubr */
  177. LVAL cvsubr(type,fcn,offset)
  178.   int type; LVAL (*fcn)(); int offset;
  179. {
  180.     LVAL val;
  181.     val = allocnode(type);
  182.     val->n_subr = fcn;
  183.     val->n_offset = offset;
  184.     return (val);
  185. }
  186.  
  187. /* cvport - convert a file pointer to an port */
  188. LVAL cvport(fp,flags)
  189.   FILE *fp; int flags;
  190. {
  191.     LVAL val;
  192.     val = allocnode(PORT);
  193.     setfile(val,fp);
  194.     setsavech(val,'\0');
  195.     setpflags(val,flags);
  196.     return (val);
  197. }
  198.  
  199. /* newvector - allocate and initialize a new vector */
  200. LVAL newvector(size)
  201.   int size;
  202. {
  203.     return (allocvector(VECTOR,size));
  204. }
  205.  
  206. /* newstring - allocate and initialize a new string */
  207. LVAL newstring(size)
  208.   int size;
  209. {
  210.     LVAL val;
  211.     val = allocvector(STRING,btow_size(size));
  212.     val->n_vsize = size;
  213.     return (val);
  214. }
  215.  
  216. /* newcode - create a new code object */
  217. LVAL newcode(nlits)
  218.   int nlits;
  219. {
  220.     return (allocvector(CODE,nlits));
  221. }
  222.  
  223. /* newcontinuation - create a new continuation object */
  224. LVAL newcontinuation(size)
  225.   int size;
  226. {
  227.     return (allocvector(CONTINUATION,size));
  228. }
  229.  
  230. /* newobject - allocate and initialize a new object */
  231. LVAL newobject(cls,size)
  232.   LVAL cls; int size;
  233. {
  234.     LVAL val;
  235.     val = allocvector(OBJECT,size+1); /* class, ivars */
  236.     setclass(val,cls);
  237.     return (val);
  238. }
  239.  
  240. /* allocnode - allocate a new node */
  241. LOCAL LVAL allocnode(type)
  242.   int type;
  243. {
  244.     LVAL nnode;
  245.  
  246.     /* get a free node */
  247.     if ((nnode = fnodes) == NIL) {
  248.     findmemory();
  249.     if ((nnode = fnodes) == NIL)
  250.         xlabort("insufficient node space");
  251.     }
  252.  
  253.     /* unlink the node from the free list */
  254.     fnodes = cdr(nnode);
  255.     --nfree;
  256.  
  257.     /* initialize the new node */
  258.     nnode->n_type = type;
  259.     rplacd(nnode,NIL);
  260.  
  261.     /* return the new node */
  262.     return (nnode);
  263. }
  264.  
  265. /* findmemory - garbage collect, then add more node space if necessary */
  266. LOCAL findmemory()
  267. {
  268.     NSEGMENT *newnsegment(),*newseg;
  269.     LVAL p;
  270.     int n;
  271.  
  272.     /* first try garbage collecting */
  273.     gc();
  274.  
  275.     /* expand memory only if less than one segment is free */
  276.     if (nfree >= (long)NSSIZE)
  277.     return;
  278.  
  279.     /* allocate the new segment */
  280.     if ((newseg = newnsegment(NSSIZE)) == NULL)
  281.     return;
  282.  
  283.     /* add each new node to the free list */
  284.     p = &newseg->ns_data[0];
  285.     for (n = NSSIZE; --n >= 0; ++p) {
  286.     p->n_type = FREE;
  287.     p->n_flags = 0;
  288.     rplacd(p,fnodes);
  289.     fnodes = p;
  290.     }
  291. }
  292.  
  293. /* allocvector - allocate and initialize a new vector node */
  294. LOCAL LVAL allocvector(type,size)
  295.   int type,size;
  296. {
  297.     register LVAL val,*p;
  298.     register int i;
  299.  
  300.     /* get a free node */
  301.     if ((val = fnodes) == NIL) {
  302.     findmemory();
  303.     if ((val = fnodes) == NIL)
  304.         xlabort("insufficient node space");
  305.     }
  306.  
  307.     /* unlink the node from the free list */
  308.     fnodes = cdr(fnodes);
  309.     --nfree;
  310.  
  311.     /* initialize the vector node */
  312.     val->n_type = type;
  313.     val->n_vsize = size;
  314.     val->n_vdata = NULL;
  315.     cpush(val);
  316.  
  317.     /* add space for the backpointer */
  318.     ++size;
  319.     
  320.     /* make sure there's enough space */
  321.     if (vfree + size >= vtop) {
  322.     findvmemory(size);
  323.     if (vfree + size >= vtop)
  324.         xlabort("insufficient vector space");
  325.     }
  326.  
  327.     /* allocate the next available block */
  328.     p = vfree;
  329.     vfree += size;
  330.     
  331.     /* store the backpointer */
  332.     *p++ = top();
  333.     val->n_vdata = p;
  334.  
  335.     /* set all the elements to NIL */
  336.     for (i = size; i > 1; --i)
  337.     *p++ = NIL;
  338.  
  339.     /* return the new vector */
  340.     return (pop());
  341. }
  342.  
  343. /* findvmemory - find vector memory (used by 'xsimage.c') */
  344. findvmemory(size)
  345.   int size;
  346. {
  347.     VSEGMENT *newvsegment(),*vseg;
  348.     
  349.     /* first try garbage collecting */
  350.     gc();
  351.  
  352.     /* look for a vector segment with enough space */
  353.     for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
  354.     if (vseg->vs_free + size < vseg->vs_top) {
  355.         if (vscurrent != NULL)
  356.         vscurrent->vs_free = vfree;
  357.         vfree = vseg->vs_free;
  358.         vtop = vseg->vs_top;
  359.         vscurrent = vseg;
  360.         return;
  361.     }
  362.     
  363.     /* allocate a new vector segment and make it current */
  364.     if (vseg = newvsegment(VSSIZE)) {
  365.     if (vscurrent != NULL)
  366.         vscurrent->vs_free = vfree;
  367.     vfree = vseg->vs_free;
  368.     vtop = vseg->vs_top;
  369.     vscurrent = vseg;
  370.     }
  371. }
  372.  
  373. /* newnsegment - create a new node segment */
  374. NSE